open Fr

(* handy functions *)

let option_may f = function
	| Some x -> f x
	| None -> ()

let option_map f = function
	| Some x -> Some (f x)
	| None -> None

let option_default d = function
	| Some x -> x
	| None -> d

let option_get = function
	| Some x -> x
	| None -> raise Not_found

let true_b = lift true
let false_b = lift false

let fix_we g f =
	fix_e (fun (w, e) -> g e) f

let fix_wb g f =
	fix_b (fun (w, b) -> g b) f

(* types *)

class type widget = object
	method widget: GObj.widget
	method expand: bool
end

type orientation = [ `Horizontal | `Vertical ]

let gtk_orientation = function
	| `Horizontal -> `HORIZONTAL
	| `Vertical -> `VERTICAL

type justification = [ `Left | `Center | `Right | `Full ]

let gtk_justification = function
	| `Left -> `LEFT
	| `Center -> `CENTER
	| `Right -> `RIGHT
	| `Full -> `FILL

type direction = [ `North | `South | `East | `West ]

let gtk_position = function
	| `North -> `TOP
	| `South -> `BOTTOM
	| `East -> `RIGHT
	| `West -> `LEFT

let direction_gtk = function
	| `TOP | `UP -> `North
	| `BOTTOM | `DOWN -> `South
	| `RIGHT -> `East
	| `LEFT -> `West

type image =
	| Pixbuf of GdkPixbuf.pixbuf
	| Stock of GtkStock.id
	| File of string

(* internal *)

let lift_signal connect =
	let r, e = event_receiver () in
	ignore (connect ~callback:(send_event r));
	e

let lift_event handled connect =
	let r, e = event_receiver () in
	ignore (connect ~callback:(fun v -> send_event r v; handled));
	e

let unregister_with w h =
	ignore (w#misc#connect#unrealize ~callback: (fun () -> unregister h))

let register_e_with w e =
	unregister_with w (register_e e)

let register_b_with w b =
	unregister_with w (register_b b)

class simple_widget ?enabled ?(expand=false)
		(widget: #GObj.widget): widget = object
	method widget = (widget :> GObj.widget)
	method expand = expand
	initializer
		option_may
			(fun enabled ->
				register_b_with widget (lift1 widget#misc#set_sensitive enabled))
			enabled
end

class static_widget ?(expand=false)
		(widget_func: unit -> #GObj.widget): widget = object
	method widget = (widget_func () :> GObj.widget)
	method expand = expand
end

class behavior_view_widget ?enabled ?expand
		widget (update: 'a -> unit) (behavior: 'a behavior): widget = object
	inherit simple_widget ?enabled ?expand widget
	initializer
		register_b_with widget (lift1 update behavior)
end

class container_widget ?expand widget: widget = object
	inherit simple_widget ?expand widget
end

let coerce_widget w = (w :> widget)
let uncoerce_widget w = (w: widget :> simple_widget)

let warnings_enabled = ref true

let warn s =
	if !warnings_enabled then
		Printf.eprintf "FrGui warning: %s\n" s

let gtk_image ?icon_size = function
	| Pixbuf pixbuf ->
		GMisc.image ~pixbuf ()
	| Stock stock ->
		GMisc.image ?icon_size ~stock ()
	| File file ->
		GMisc.image ~file ()
